home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / bin / enc2xs < prev    next >
Text File  |  2009-10-01  |  39KB  |  1,411 lines
  1. #!/usr/bin/perl
  2.     eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
  3.     if $running_under_some_shell;
  4. #!./perl
  5. BEGIN {
  6.     # @INC poking  no longer needed w/ new MakeMaker and Makefile.PL's
  7.     # with $ENV{PERL_CORE} set
  8.     # In case we need it in future...
  9.     require Config; import Config;
  10. }
  11. use strict;
  12. use warnings;
  13. use Getopt::Std;
  14. use Config;
  15. my @orig_ARGV = @ARGV;
  16. our $VERSION  = do { my @r = (q$Revision: 2.5 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
  17.  
  18. # These may get re-ordered.
  19. # RAW is a do_now as inserted by &enter
  20. # AGG is an aggreagated do_now, as built up by &process
  21.  
  22. use constant {
  23.   RAW_NEXT => 0,
  24.   RAW_IN_LEN => 1,
  25.   RAW_OUT_BYTES => 2,
  26.   RAW_FALLBACK => 3,
  27.  
  28.   AGG_MIN_IN => 0,
  29.   AGG_MAX_IN => 1,
  30.   AGG_OUT_BYTES => 2,
  31.   AGG_NEXT => 3,
  32.   AGG_IN_LEN => 4,
  33.   AGG_OUT_LEN => 5,
  34.   AGG_FALLBACK => 6,
  35. };
  36.  
  37. # (See the algorithm in encengine.c - we're building structures for it)
  38.  
  39. # There are two sorts of structures.
  40. # "do_now" (an array, two variants of what needs storing) is whatever we need
  41. # to do now we've read an input byte.
  42. # It's housed in a "do_next" (which is how we got to it), and in turn points
  43. # to a "do_next" which contains all the "do_now"s for the next input byte.
  44.  
  45. # There will be a "do_next" which is the start state.
  46. # For a single byte encoding it's the only "do_next" - each "do_now" points
  47. # back to it, and each "do_now" will cause bytes. There is no state.
  48.  
  49. # For a multi-byte encoding where all characters in the input are the same
  50. # length, then there will be a tree of "do_now"->"do_next"->"do_now"
  51. # branching out from the start state, one step for each input byte.
  52. # The leaf "do_now"s will all be at the same distance from the start state,
  53. # only the leaf "do_now"s cause output bytes, and they in turn point back to
  54. # the start state.
  55.  
  56. # For an encoding where there are varaible length input byte sequences, you
  57. # will encounter a leaf "do_now" sooner for the shorter input sequences, but
  58. # as before the leaves will point back to the start state.
  59.  
  60. # The system will cope with escape encodings (imagine them as a mostly
  61. # self-contained tree for each escape state, and cross links between trees
  62. # at the state-switching characters) but so far no input format defines these.
  63.  
  64. # The system will also cope with having output "leaves" in the middle of
  65. # the bifurcating branches, not just at the extremities, but again no
  66. # input format does this yet.
  67.  
  68. # There are two variants of the "do_now" structure. The first, smaller variant
  69. # is generated by &enter as the input file is read. There is one structure
  70. # for each input byte. Say we are mapping a single byte encoding to a
  71. # single byte encoding, with  "ABCD" going "abcd". There will be
  72. # 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
  73.  
  74. # &process then walks the tree, building aggregate "do_now" structres for
  75. # adjacent bytes where possible. The aggregate is for a contiguous range of
  76. # bytes which each produce the same length of output, each move to the
  77. # same next state, and each have the same fallback flag.
  78. # So our 4 RAW "do_now"s above become replaced by a single structure
  79. # containing:
  80. # ["A", "D", "abcd", 1, ...]
  81. # ie, for an input byte $_ in "A".."D", output 1 byte, found as
  82. # substr ("abcd", (ord $_ - ord "A") * 1, 1)
  83. # which maps very nicely into pointer arithmetic in C for encengine.c
  84.  
  85. sub encode_U
  86. {
  87.  # UTF-8 encode long hand - only covers part of perl's range
  88.  ## my $uv = shift;
  89.  # chr() works in native space so convert value from table
  90.  # into that space before using chr().
  91.  my $ch = chr(utf8::unicode_to_native($_[0]));
  92.  # Now get core perl to encode that the way it likes.
  93.  utf8::encode($ch);
  94.  return $ch;
  95. }
  96.  
  97. sub encode_S
  98. {
  99.  # encode single byte
  100.  ## my ($ch,$page) = @_; return chr($ch);
  101.  return chr $_[0];
  102. }
  103.  
  104. sub encode_D
  105. {
  106.  # encode double byte MS byte first
  107.  ## my ($ch,$page) = @_; return chr($page).chr($ch);
  108.  return chr ($_[1]) . chr $_[0];
  109. }
  110.  
  111. sub encode_M
  112. {
  113.  # encode Multi-byte - single for 0..255 otherwise double
  114.  ## my ($ch,$page) = @_;
  115.  ## return &encode_D if $page;
  116.  ## return &encode_S;
  117.  return chr ($_[1]) . chr $_[0] if $_[1];
  118.  return chr $_[0];
  119. }
  120.  
  121. my %encode_types = (U => \&encode_U,
  122.                     S => \&encode_S,
  123.                     D => \&encode_D,
  124.                     M => \&encode_M,
  125.                    );
  126.  
  127. # Win32 does not expand globs on command line
  128. eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
  129.  
  130. my %opt;
  131. # I think these are:
  132. # -Q to disable the duplicate codepoint test
  133. # -S make mapping errors fatal
  134. # -q to remove comments written to output files
  135. # -O to enable the (brute force) substring optimiser
  136. # -o <output> to specify the output file name (else it's the first arg)
  137. # -f <inlist> to give a file with a list of input files (else use the args)
  138. # -n <name> to name the encoding (else use the basename of the input file.
  139. getopts('CM:SQqOo:f:n:',\%opt);
  140.  
  141. $opt{M} and make_makefile_pl($opt{M}, @ARGV);
  142. $opt{C} and make_configlocal_pm($opt{C}, @ARGV);
  143.  
  144. # This really should go first, else the die here causes empty (non-erroneous)
  145. # output files to be written.
  146. my @encfiles;
  147. if (exists $opt{'f'}) {
  148.     # -F is followed by name of file containing list of filenames
  149.     my $flist = $opt{'f'};
  150.     open(FLIST,$flist) || die "Cannot open $flist:$!";
  151.     chomp(@encfiles = <FLIST>);
  152.     close(FLIST);
  153. } else {
  154.     @encfiles = @ARGV;
  155. }
  156.  
  157. my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
  158. chmod(0666,$cname) if -f $cname && !-w $cname;
  159. open(C,">$cname") || die "Cannot open $cname:$!";
  160.  
  161. my $dname = $cname;
  162. my $hname = $cname;
  163.  
  164. my ($doC,$doEnc,$doUcm,$doPet);
  165.  
  166. if ($cname =~ /\.(c|xs)$/i) # VMS may have upcased filenames with DECC$ARGV_PARSE_STYLE defined
  167.  {
  168.   $doC = 1;
  169.   $dname =~ s/(\.[^\.]*)?$/.exh/;
  170.   chmod(0666,$dname) if -f $cname && !-w $dname;
  171.   open(D,">$dname") || die "Cannot open $dname:$!";
  172.   $hname =~ s/(\.[^\.]*)?$/.h/;
  173.   chmod(0666,$hname) if -f $cname && !-w $hname;
  174.   open(H,">$hname") || die "Cannot open $hname:$!";
  175.  
  176.   foreach my $fh (\*C,\*D,\*H)
  177.   {
  178.    print $fh <<"END" unless $opt{'q'};
  179. /*
  180.  !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  181.  This file was autogenerated by:
  182.  $^X $0 @orig_ARGV
  183.  enc2xs VERSION $VERSION
  184. */
  185. END
  186.   }
  187.  
  188.   if ($cname =~ /(\w+)\.xs$/)
  189.    {
  190.     print C "#include <EXTERN.h>\n";
  191.     print C "#include <perl.h>\n";
  192.     print C "#include <XSUB.h>\n";
  193.     print C "#define U8 U8\n";
  194.    }
  195.   print C "#include \"encode.h\"\n\n";
  196.  
  197.  }
  198. elsif ($cname =~ /\.enc$/)
  199.  {
  200.   $doEnc = 1;
  201.  }
  202. elsif ($cname =~ /\.ucm$/)
  203.  {
  204.   $doUcm = 1;
  205.  }
  206. elsif ($cname =~ /\.pet$/)
  207.  {
  208.   $doPet = 1;
  209.  }
  210.  
  211. my %encoding;
  212. my %strings;
  213. my $string_acc;
  214. my %strings_in_acc;
  215.  
  216. my $saved = 0;
  217. my $subsave = 0;
  218. my $strings = 0;
  219.  
  220. sub cmp_name
  221. {
  222.  if ($a =~ /^.*-(\d+)/)
  223.   {
  224.    my $an = $1;
  225.    if ($b =~ /^.*-(\d+)/)
  226.     {
  227.      my $r = $an <=> $1;
  228.      return $r if $r;
  229.     }
  230.   }
  231.  return $a cmp $b;
  232. }
  233.  
  234.  
  235. foreach my $enc (sort cmp_name @encfiles)
  236.  {
  237.   my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
  238.   $name = $opt{'n'} if exists $opt{'n'};
  239.   if (open(E,$enc))
  240.    {
  241.     if ($sfx eq 'enc')
  242.      {
  243.       compile_enc(\*E,lc($name));
  244.      }
  245.     else
  246.      {
  247.       compile_ucm(\*E,lc($name));
  248.      }
  249.    }
  250.   else
  251.    {
  252.     warn "Cannot open $enc for $name:$!";
  253.    }
  254.  }
  255.  
  256. if ($doC)
  257.  {
  258.   print STDERR "Writing compiled form\n";
  259.   foreach my $name (sort cmp_name keys %encoding)
  260.    {
  261.     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
  262.     process($name.'_utf8',$e2u);
  263.     addstrings(\*C,$e2u);
  264.  
  265.     process('utf8_'.$name,$u2e);
  266.     addstrings(\*C,$u2e);
  267.    }
  268.   outbigstring(\*C,"enctable");
  269.   foreach my $name (sort cmp_name keys %encoding)
  270.    {
  271.     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
  272.     outtable(\*C,$e2u, "enctable");
  273.     outtable(\*C,$u2e, "enctable");
  274.  
  275.     # push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
  276.    }
  277.   my $cpp = ($Config{d_cplusplus} || '') eq 'define';
  278.   my $exta = $cpp ? 'extern "C" ' : "static";
  279.   my $extb = $cpp ? 'extern "C" ' : "";
  280.   foreach my $enc (sort cmp_name keys %encoding)
  281.    {
  282.     # my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
  283.     my ($e2u,$u2e,$rep,$min_el,$max_el) = @{$encoding{$enc}};
  284.     #my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
  285.     my $replen = 0; 
  286.     $replen++ while($rep =~ /\G\\x[0-9A-Fa-f]/g);
  287.     my $sym = "${enc}_encoding";
  288.     $sym =~ s/\W+/_/g;
  289.     my @info = ($e2u->{Cname},$u2e->{Cname},"${sym}_rep_character",$replen,
  290.         $min_el,$max_el);
  291.     print C "${exta} const U8 ${sym}_rep_character[] = \"$rep\";\n";
  292.     print C "${exta} const char ${sym}_enc_name[] = \"$enc\";\n\n";
  293.     print C "${extb} const encode_t $sym = \n";
  294.     # This is to make null encoding work -- dankogai
  295.     for (my $i = (scalar @info) - 1;  $i >= 0; --$i){
  296.     $info[$i] ||= 1;
  297.     }
  298.     # end of null tweak -- dankogai
  299.     print C " {",join(',',@info,"{${sym}_enc_name,(const char *)0}"),"};\n\n";
  300.    }
  301.  
  302.   foreach my $enc (sort cmp_name keys %encoding)
  303.    {
  304.     my $sym = "${enc}_encoding";
  305.     $sym =~ s/\W+/_/g;
  306.     print H "extern encode_t $sym;\n";
  307.     print D " Encode_XSEncoding(aTHX_ &$sym);\n";
  308.    }
  309.  
  310.   if ($cname =~ /(\w+)\.xs$/)
  311.    {
  312.     my $mod = $1;
  313.     print C <<'END';
  314.  
  315. static void
  316. Encode_XSEncoding(pTHX_ encode_t *enc)
  317. {
  318.  dSP;
  319.  HV *stash = gv_stashpv("Encode::XS", TRUE);
  320.  SV *sv    = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
  321.  int i = 0;
  322.  PUSHMARK(sp);
  323.  XPUSHs(sv);
  324.  while (enc->name[i])
  325.   {
  326.    const char *name = enc->name[i++];
  327.    XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
  328.   }
  329.  PUTBACK;
  330.  call_pv("Encode::define_encoding",G_DISCARD);
  331.  SvREFCNT_dec(sv);
  332. }
  333.  
  334. END
  335.  
  336.     print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
  337.     print C "BOOT:\n{\n";
  338.     print C "#include \"$dname\"\n";
  339.     print C "}\n";
  340.    }
  341.   # Close in void context is bad, m'kay
  342.   close(D) or warn "Error closing '$dname': $!";
  343.   close(H) or warn "Error closing '$hname': $!";
  344.  
  345.   my $perc_saved    = $saved/($strings + $saved) * 100;
  346.   my $perc_subsaved = $subsave/($strings + $subsave) * 100;
  347.   printf STDERR "%d bytes in string tables\n",$strings;
  348.   printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
  349.     $saved, $perc_saved              if $saved;
  350.   printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
  351.     $subsave, $perc_subsaved         if $subsave;
  352.  }
  353. elsif ($doEnc)
  354.  {
  355.   foreach my $name (sort cmp_name keys %encoding)
  356.    {
  357.     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
  358.     output_enc(\*C,$name,$e2u);
  359.    }
  360.  }
  361. elsif ($doUcm)
  362.  {
  363.   foreach my $name (sort cmp_name keys %encoding)
  364.    {
  365.     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
  366.     output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
  367.    }
  368.  }
  369.  
  370. # writing half meg files and then not checking to see if you just filled the
  371. # disk is bad, m'kay
  372. close(C) or die "Error closing '$cname': $!";
  373.  
  374. # End of the main program.
  375.  
  376. sub compile_ucm
  377. {
  378.  my ($fh,$name) = @_;
  379.  my $e2u = {};
  380.  my $u2e = {};
  381.  my $cs;
  382.  my %attr;
  383.  while (<$fh>)
  384.   {
  385.    s/#.*$//;
  386.    last if /^\s*CHARMAP\s*$/i;
  387.    if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
  388.     {
  389.      $attr{$1} = $2;
  390.     }
  391.   }
  392.  if (!defined($cs =  $attr{'code_set_name'}))
  393.   {
  394.    warn "No <code_set_name> in $name\n";
  395.   }
  396.  else
  397.   {
  398.    $name = $cs unless exists $opt{'n'};
  399.   }
  400.  my $erep;
  401.  my $urep;
  402.  my $max_el;
  403.  my $min_el;
  404.  if (exists $attr{'subchar'})
  405.   {
  406.    #my @byte;
  407.    #$attr{'subchar'} =~ /^\s*/cg;
  408.    #push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
  409.    #$erep = join('',map(chr(hex($_)),@byte));
  410.    $erep = $attr{'subchar'}; 
  411.    $erep =~ s/^\s+//; $erep =~ s/\s+$//;
  412.   }
  413.  print "Reading $name ($cs)\n";
  414.  my $nfb = 0;
  415.  my $hfb = 0;
  416.  while (<$fh>)
  417.   {
  418.    s/#.*$//;
  419.    last if /^\s*END\s+CHARMAP\s*$/i;
  420.    next if /^\s*$/;
  421.    my (@uni, @byte) = ();
  422.    my ($uni, $byte, $fb) = m/^(\S+)\s+(\S+)\s+(\S+)\s+/o
  423.        or die "Bad line: $_";
  424.    while ($uni =~  m/\G<([U0-9a-fA-F\+]+)>/g){
  425.        push @uni, map { substr($_, 1) } split(/\+/, $1);
  426.    }
  427.    while ($byte =~ m/\G\\x([0-9a-fA-F]+)/g){
  428.        push @byte, $1;
  429.    }
  430.    if (@uni)
  431.     {
  432.      my $uch =  join('', map { encode_U(hex($_)) } @uni );
  433.      my $ech = join('',map(chr(hex($_)),@byte));
  434.      my $el  = length($ech);
  435.      $max_el = $el if (!defined($max_el) || $el > $max_el);
  436.      $min_el = $el if (!defined($min_el) || $el < $min_el);
  437.      if (length($fb))
  438.       {
  439.        $fb = substr($fb,1);
  440.        $hfb++;
  441.       }
  442.      else
  443.       {
  444.        $nfb++;
  445.        $fb = '0';
  446.       }
  447.      # $fb is fallback flag
  448.      # 0 - round trip safe
  449.      # 1 - fallback for unicode -> enc
  450.      # 2 - skip sub-char mapping
  451.      # 3 - fallback enc -> unicode
  452.      enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
  453.      enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
  454.     }
  455.    else
  456.     {
  457.      warn $_;
  458.     }
  459.   }
  460.  if ($nfb && $hfb)
  461.   {
  462.    die "$nfb entries without fallback, $hfb entries with\n";
  463.   }
  464.  $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
  465. }
  466.  
  467.  
  468.  
  469. sub compile_enc
  470. {
  471.  my ($fh,$name) = @_;
  472.  my $e2u = {};
  473.  my $u2e = {};
  474.  
  475.  my $type;
  476.  while ($type = <$fh>)
  477.   {
  478.    last if $type !~ /^\s*#/;
  479.   }
  480.  chomp($type);
  481.  return if $type eq 'E';
  482.  # Do the hash lookup once, rather than once per function call. 4% speedup.
  483.  my $type_func = $encode_types{$type};
  484.  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
  485.  warn "$type encoded $name\n";
  486.  my $rep = '';
  487.  # Save a defined test by setting these to defined values.
  488.  my $min_el = ~0; # A very big integer
  489.  my $max_el = 0;  # Anything must be longer than 0
  490.  {
  491.   my $v = hex($def);
  492.   $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
  493.  }
  494.  my $errors;
  495.  my $seen;
  496.  # use -Q to silence the seen test. Makefile.PL uses this by default.
  497.  $seen = {} unless $opt{Q};
  498.  do
  499.   {
  500.    my $line = <$fh>;
  501.    chomp($line);
  502.    my $page = hex($line);
  503.    my $ch = 0;
  504.    my $i = 16;
  505.    do
  506.     {
  507.      # So why is it 1% faster to leave the my here?
  508.      my $line = <$fh>;
  509.      $line =~ s/\r\n$/\n/;
  510.      die "$.:${line}Line should be exactly 65 characters long including
  511.      newline (".length($line).")" unless length ($line) == 65;
  512.      # Split line into groups of 4 hex digits, convert groups to ints
  513.      # This takes 65.35        
  514.      # map {hex $_} $line =~ /(....)/g
  515.      # This takes 63.75 (2.5% less time)
  516.      # unpack "n*", pack "H*", $line
  517.      # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
  518.      # Doing it as while ($line =~ /(....)/g) took 74.63
  519.      foreach my $val (unpack "n*", pack "H*", $line)
  520.       {
  521.        next if $val == 0xFFFD;
  522.        my $ech = &$type_func($ch,$page);
  523.        if ($val || (!$ch && !$page))
  524.         {
  525.          my $el  = length($ech);
  526.          $max_el = $el if $el > $max_el;
  527.          $min_el = $el if $el < $min_el;
  528.          my $uch = encode_U($val);
  529.          if ($seen) {
  530.            # We're doing the test.
  531.            # We don't need to read this quickly, so storing it as a scalar,
  532.            # rather than 3 (anon array, plus the 2 scalars it holds) saves
  533.            # RAM and may make us faster on low RAM systems. [see __END__]
  534.            if (exists $seen->{$uch})
  535.              {
  536.                warn sprintf("U%04X is %02X%02X and %04X\n",
  537.                             $val,$page,$ch,$seen->{$uch});
  538.                $errors++;
  539.              }
  540.            else
  541.              {
  542.                $seen->{$uch} = $page << 8 | $ch;
  543.              }
  544.          }
  545.          # Passing 2 extra args each time is 3.6% slower!
  546.          # Even with having to add $fallback ||= 0 later
  547.          enter_fb0($e2u,$ech,$uch);
  548.          enter_fb0($u2e,$uch,$ech);
  549.         }
  550.        else
  551.         {
  552.          # No character at this position
  553.          # enter($e2u,$ech,undef,$e2u);
  554.         }
  555.        $ch++;
  556.       }
  557.     } while --$i;
  558.   } while --$pages;
  559.  die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
  560.    if $min_el > $max_el;
  561.  die "$errors mapping conflicts\n" if ($errors && $opt{'S'});
  562.  $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
  563. }
  564.  
  565. # my ($a,$s,$d,$t,$fb) = @_;
  566. sub enter {
  567.   my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
  568.   # state we shift to after this (multibyte) input character defaults to same
  569.   # as current state.
  570.   $next ||= $current;
  571.   # Making sure it is defined seems to be faster than {no warnings;} in
  572.   # &process, or passing it in as 0 explicity.
  573.   # XXX $fallback ||= 0;
  574.  
  575.   # Start at the beginning and work forwards through the string to zero.
  576.   # effectively we are removing 1 character from the front each time
  577.   # but we don't actually edit the string. [this alone seems to be 14% speedup]
  578.   # Hence -$pos is the length of the remaining string.
  579.   my $pos = -length $inbytes;
  580.   while (1) {
  581.     my $byte = substr $inbytes, $pos, 1;
  582.     #  RAW_NEXT => 0,
  583.     #  RAW_IN_LEN => 1,
  584.     #  RAW_OUT_BYTES => 2,
  585.     #  RAW_FALLBACK => 3,
  586.     # to unicode an array would seem to be better, because the pages are dense.
  587.     # from unicode can be very sparse, favouring a hash.
  588.     # hash using the bytes (all length 1) as keys rather than ord value,
  589.     # as it's easier to sort these in &process.
  590.  
  591.     # It's faster to always add $fallback even if it's undef, rather than
  592.     # choosing between 3 and 4 element array. (hence why we set it defined
  593.     # above)
  594.     my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
  595.     # When $pos was -1 we were at the last input character.
  596.     unless (++$pos) {
  597.       $do_now->[RAW_OUT_BYTES] = $outbytes;
  598.       $do_now->[RAW_NEXT] = $next;
  599.       return;
  600.     }
  601.     # Tail recursion. The intermdiate state may not have a name yet.
  602.     $current = $do_now->[RAW_NEXT];
  603.   }
  604. }
  605.  
  606. # This is purely for optimistation. It's just &enter hard coded for $fallback
  607. # of 0, using only a 3 entry array ref to save memory for every entry.
  608. sub enter_fb0 {
  609.   my ($current,$inbytes,$outbytes,$next) = @_;
  610.   $next ||= $current;
  611.  
  612.   my $pos = -length $inbytes;
  613.   while (1) {
  614.     my $byte = substr $inbytes, $pos, 1;
  615.     my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
  616.     unless (++$pos) {
  617.       $do_now->[RAW_OUT_BYTES] = $outbytes;
  618.       $do_now->[RAW_NEXT] = $next;
  619.       return;
  620.     }
  621.     $current = $do_now->[RAW_NEXT];
  622.   }
  623. }
  624.  
  625. sub process
  626. {
  627.   my ($name,$a) = @_;
  628.   $name =~ s/\W+/_/g;
  629.   $a->{Cname} = $name;
  630.   my $raw = $a->{Raw};
  631.   my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
  632.   my @ent;
  633.   $agg_max_in = 0;
  634.   foreach my $key (sort keys %$raw) {
  635.     #  RAW_NEXT => 0,
  636.     #  RAW_IN_LEN => 1,
  637.     #  RAW_OUT_BYTES => 2,
  638.     #  RAW_FALLBACK => 3,
  639.     my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
  640.     # Now we are converting from raw to aggregate, switch from 1 byte strings
  641.     # to numbers
  642.     my $b = ord $key;
  643.     $fallback ||= 0;
  644.     if ($l &&
  645.         # If this == fails, we're going to reset $agg_max_in below anyway.
  646.         $b == ++$agg_max_in &&
  647.         # References in numeric context give the pointer as an int.
  648.         $agg_next == $next &&
  649.         $agg_in_len == $in_len &&
  650.         $agg_out_len == length $out_bytes &&
  651.         $agg_fallback == $fallback
  652.         # && length($l->[AGG_OUT_BYTES]) < 16
  653.        ) {
  654.       #     my $i = ord($b)-ord($l->[AGG_MIN_IN]);
  655.       # we can aggregate this byte onto the end.
  656.       $l->[AGG_MAX_IN] = $b;
  657.       $l->[AGG_OUT_BYTES] .= $out_bytes;
  658.     } else {
  659.       # AGG_MIN_IN => 0,
  660.       # AGG_MAX_IN => 1,
  661.       # AGG_OUT_BYTES => 2,
  662.       # AGG_NEXT => 3,
  663.       # AGG_IN_LEN => 4,
  664.       # AGG_OUT_LEN => 5,
  665.       # AGG_FALLBACK => 6,
  666.       # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
  667.       # (only gains .6% on euc-jp  -- is it worth it?)
  668.       push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
  669.                        $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
  670.                        $agg_fallback = $fallback];
  671.     }
  672.     if (exists $next->{Cname}) {
  673.       $next->{'Forward'} = 1 if $next != $a;
  674.     } else {
  675.       process(sprintf("%s_%02x",$name,$b),$next);
  676.     }
  677.   }
  678.   # encengine.c rules say that last entry must be for 255
  679.   if ($agg_max_in < 255) {
  680.     push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
  681.   }
  682.   $a->{'Entries'} = \@ent;
  683. }
  684.  
  685.  
  686. sub addstrings
  687. {
  688.  my ($fh,$a) = @_;
  689.  my $name = $a->{'Cname'};
  690.  # String tables
  691.  foreach my $b (@{$a->{'Entries'}})
  692.   {
  693.    next unless $b->[AGG_OUT_LEN];
  694.    $strings{$b->[AGG_OUT_BYTES]} = undef;
  695.   }
  696.  if ($a->{'Forward'})
  697.   {
  698.    my $cpp = ($Config{d_cplusplus} || '') eq 'define';
  699.    my $var = $^O eq 'MacOS' || $cpp ? 'extern' : 'static';
  700.    my $const = $cpp ? '' : 'const';
  701.    print $fh "$var $const encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
  702.   }
  703.  $a->{'DoneStrings'} = 1;
  704.  foreach my $b (@{$a->{'Entries'}})
  705.   {
  706.    my ($s,$e,$out,$t,$end,$l) = @$b;
  707.    addstrings($fh,$t) unless $t->{'DoneStrings'};
  708.   }
  709. }
  710.  
  711. sub outbigstring
  712. {
  713.   my ($fh,$name) = @_;
  714.  
  715.   $string_acc = '';
  716.  
  717.   # Make the big string in the string accumulator. Longest first, on the hope
  718.   # that this makes it more likely that we find the short strings later on.
  719.   # Not sure if it helps sorting strings of the same length lexcically.
  720.   foreach my $s (sort {length $b <=> length $a || $a cmp $b} keys %strings) {
  721.     my $index = index $string_acc, $s;
  722.     if ($index >= 0) {
  723.       $saved += length($s);
  724.       $strings_in_acc{$s} = $index;
  725.     } else {
  726.     OPTIMISER: {
  727.     if ($opt{'O'}) {
  728.       my $sublength = length $s;
  729.       while (--$sublength > 0) {
  730.         # progressively lop characters off the end, to see if the start of
  731.         # the new string overlaps the end of the accumulator.
  732.         if (substr ($string_acc, -$sublength)
  733.         eq substr ($s, 0, $sublength)) {
  734.           $subsave += $sublength;
  735.           $strings_in_acc{$s} = length ($string_acc) - $sublength;
  736.           # append the last bit on the end.
  737.           $string_acc .= substr ($s, $sublength);
  738.           last OPTIMISER;
  739.         }
  740.         # or if the end of the new string overlaps the start of the
  741.         # accumulator
  742.         next unless substr ($string_acc, 0, $sublength)
  743.           eq substr ($s, -$sublength);
  744.         # well, the last $sublength characters of the accumulator match.
  745.         # so as we're prepending to the accumulator, need to shift all our
  746.         # existing offsets forwards
  747.         $_ += $sublength foreach values %strings_in_acc;
  748.         $subsave += $sublength;
  749.         $strings_in_acc{$s} = 0;
  750.         # append the first bit on the start.
  751.         $string_acc = substr ($s, 0, -$sublength) . $string_acc;
  752.         last OPTIMISER;
  753.       }
  754.     }
  755.     # Optimiser (if it ran) found nothing, so just going have to tack the
  756.     # whole thing on the end.
  757.     $strings_in_acc{$s} = length $string_acc;
  758.     $string_acc .= $s;
  759.       };
  760.     }
  761.   }
  762.  
  763.   $strings = length $string_acc;
  764.   my $cpp = ($Config{d_cplusplus} || '') eq 'define';
  765.   my $var = $cpp ? '' : 'static';
  766.   my $definition = "\n$var const U8 $name\[$strings] = { " .
  767.     join(',',unpack "C*",$string_acc);
  768.   # We have a single long line. Split it at convenient commas.
  769.   print $fh $1, "\n" while $definition =~ /\G(.{74,77},)/gcs;
  770.   print $fh substr ($definition, pos $definition), " };\n";
  771. }
  772.  
  773. sub findstring {
  774.   my ($name,$s) = @_;
  775.   my $offset = $strings_in_acc{$s};
  776.   die "Can't find string " . join (',',unpack "C*",$s) . " in accumulator"
  777.     unless defined $offset;
  778.   "$name + $offset";
  779. }
  780.  
  781. sub outtable
  782. {
  783.  my ($fh,$a,$bigname) = @_;
  784.  my $name = $a->{'Cname'};
  785.  $a->{'Done'} = 1;
  786.  foreach my $b (@{$a->{'Entries'}})
  787.   {
  788.    my ($s,$e,$out,$t,$end,$l) = @$b;
  789.    outtable($fh,$t,$bigname) unless $t->{'Done'};
  790.   }
  791.  my $cpp = ($Config{d_cplusplus} || '') eq 'define';
  792.  my $var = $cpp ? '' : 'static';
  793.  my $const = $cpp ? '' : 'const';
  794.  print $fh "\n$var $const encpage_t $name\[",
  795.    scalar(@{$a->{'Entries'}}), "] = {\n";
  796.  foreach my $b (@{$a->{'Entries'}})
  797.   {
  798.    my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
  799.    # $end |= 0x80 if $fb; # what the heck was on your mind, Nick?  -- Dan
  800.    print  $fh "{";
  801.    if ($l)
  802.     {
  803.      printf $fh findstring($bigname,$out);
  804.     }
  805.    else
  806.     {
  807.      print  $fh "0";
  808.     }
  809.    print  $fh ",",$t->{Cname};
  810.    printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
  811.   }
  812.  print $fh "};\n";
  813. }
  814.  
  815. sub output_enc
  816. {
  817.  my ($fh,$name,$a) = @_;
  818.  die "Changed - fix me for new structure";
  819.  foreach my $b (sort keys %$a)
  820.   {
  821.    my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
  822.   }
  823. }
  824.  
  825. sub decode_U
  826. {
  827.  my $s = shift;
  828. }
  829.  
  830. my @uname;
  831. sub char_names
  832. {
  833.  my $s = do "unicore/Name.pl";
  834.  die "char_names: unicore/Name.pl: $!\n" unless defined $s;
  835.  pos($s) = 0;
  836.  while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
  837.   {
  838.    my $name = $3;
  839.    my $s = hex($1);
  840.    last if $s >= 0x10000;
  841.    my $e = length($2) ? hex($2) : $s;
  842.    for (my $i = $s; $i <= $e; $i++)
  843.     {
  844.      $uname[$i] = $name;
  845. #    print sprintf("U%04X $name\n",$i);
  846.     }
  847.   }
  848. }
  849.  
  850. sub output_ucm_page
  851. {
  852.   my ($cmap,$a,$t,$pre) = @_;
  853.   # warn sprintf("Page %x\n",$pre);
  854.   my $raw = $t->{Raw};
  855.   foreach my $key (sort keys %$raw) {
  856.     #  RAW_NEXT => 0,
  857.     #  RAW_IN_LEN => 1,
  858.     #  RAW_OUT_BYTES => 2,
  859.     #  RAW_FALLBACK => 3,
  860.     my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
  861.     my $u = ord $key;
  862.     $fallback ||= 0;
  863.  
  864.     if ($next != $a && $next != $t) {
  865.       output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
  866.     } elsif (length $out_bytes) {
  867.       if ($pre) {
  868.         $u = $pre|($u &0x3f);
  869.       }
  870.       my $s = sprintf "<U%04X> ",$u;
  871.       #foreach my $c (split(//,$out_bytes)) {
  872.       #  $s .= sprintf "\\x%02X",ord($c);
  873.       #}
  874.       # 9.5% faster changing that loop to this:
  875.       $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
  876.       $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
  877.       push(@$cmap,$s);
  878.     } else {
  879.       warn join(',',$u, @{$raw->{$key}},$a,$t);
  880.     }
  881.   }
  882. }
  883.  
  884. sub output_ucm
  885. {
  886.  my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
  887.  print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
  888.  print $fh "<code_set_name> \"$name\"\n";
  889.  char_names();
  890.  if (defined $min_el)
  891.   {
  892.    print $fh "<mb_cur_min> $min_el\n";
  893.   }
  894.  if (defined $max_el)
  895.   {
  896.    print $fh "<mb_cur_max> $max_el\n";
  897.   }
  898.  if (defined $rep)
  899.   {
  900.    print $fh "<subchar> ";
  901.    foreach my $c (split(//,$rep))
  902.     {
  903.      printf $fh "\\x%02X",ord($c);
  904.     }
  905.    print $fh "\n";
  906.   }
  907.  my @cmap;
  908.  output_ucm_page(\@cmap,$h,$h,0);
  909.  print $fh "#\nCHARMAP\n";
  910.  foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
  911.   {
  912.    print $fh $line;
  913.   }
  914.  print $fh "END CHARMAP\n";
  915. }
  916.  
  917. use vars qw(
  918.     $_Enc2xs
  919.     $_Version
  920.     $_Inc
  921.     $_E2X 
  922.     $_Name
  923.     $_TableFiles
  924.     $_Now
  925. );
  926.  
  927. sub find_e2x{
  928.     eval { require File::Find; };
  929.     my (@inc, %e2x_dir);
  930.     for my $inc (grep -d, @INC){
  931.     push @inc, $inc unless $inc eq '.'; #skip current dir
  932.     }
  933.     File::Find::find(
  934.          { wanted => sub {
  935.          my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  936.              $atime,$mtime,$ctime,$blksize,$blocks)
  937.              = lstat($_) or return;
  938.          -f _ or return;
  939.          if (/^.*\.e2x$/o){
  940.              no warnings 'once';
  941.              $e2x_dir{$File::Find::dir} ||= $mtime;
  942.          }
  943.          return;
  944.          }, follow => 1}, @inc);
  945.     warn join("\n", keys %e2x_dir), "\n";
  946.     for my $d (sort {$e2x_dir{$a} <=> $e2x_dir{$b}} keys %e2x_dir){
  947.     $_E2X = $d;
  948.     # warn "$_E2X => ", scalar localtime($e2x_dir{$d});
  949.     return $_E2X;
  950.     }
  951. }
  952.  
  953. sub make_makefile_pl
  954. {
  955.     eval { require Encode; };
  956.     $@ and die "You need to install Encode to use enc2xs -M\nerror: $@\n";
  957.     # our used for variable expanstion
  958.     $_Enc2xs = $0;
  959.     $_Version = $VERSION;
  960.     $_E2X = find_e2x();
  961.     $_Name = shift;
  962.     $_TableFiles = join(",", map {qq('$_')} @_);
  963.     $_Now = scalar localtime();
  964.  
  965.     eval { require File::Spec; };
  966.     _print_expand(File::Spec->catfile($_E2X,"Makefile_PL.e2x"),"Makefile.PL");
  967.     _print_expand(File::Spec->catfile($_E2X,"_PM.e2x"),        "$_Name.pm");
  968.     _print_expand(File::Spec->catfile($_E2X,"_T.e2x"),         "t/$_Name.t");
  969.     _print_expand(File::Spec->catfile($_E2X,"README.e2x"),     "README");
  970.     _print_expand(File::Spec->catfile($_E2X,"Changes.e2x"),    "Changes");
  971.     exit;
  972. }
  973.  
  974. use vars qw(
  975.         $_ModLines
  976.         $_LocalVer
  977.         );
  978.  
  979. sub make_configlocal_pm {
  980.     eval { require Encode; };
  981.     $@ and die "Unable to require Encode: $@\n";
  982.     eval { require File::Spec; };
  983.  
  984.     # our used for variable expanstion
  985.     my %in_core = map { $_ => 1 } (
  986.         'ascii',      'iso-8859-1', 'utf8',
  987.         'ascii-ctrl', 'null',       'utf-8-strict'
  988.     );
  989.     my %LocalMod = ();
  990.     # check @enc;
  991.     use File::Find ();
  992.     my $wanted = sub{
  993.     -f $_ or return;
  994.     $File::Find::name =~ /\A\./        and return;
  995.     $File::Find::name =~ /\.pm\z/      or  return;
  996.     $File::Find::name =~ m/\bEncode\b/ or  return;
  997.     my $mod = $File::Find::name;
  998.     $mod =~ s/.*\bEncode\b/Encode/o;
  999.     $mod =~ s/\.pm\z//o;
  1000.     $mod =~ s,/,::,og;
  1001.     warn qq{ require $mod;\n};
  1002.     eval qq{ require $mod; };
  1003.     $@ and die "Can't require $mod: $@\n";
  1004.     for my $enc ( Encode->encodings() ) {
  1005.         no warnings;
  1006.         $in_core{$enc}                   and next;
  1007.         $Encode::Config::ExtModule{$enc} and next;
  1008.         $LocalMod{$enc} ||= $mod;
  1009.     }
  1010.     };
  1011.     File::Find::find({wanted => $wanted, follow => 1}, grep -d, @INC);
  1012.     $_ModLines = "";
  1013.     for my $enc ( sort keys %LocalMod ) {
  1014.         $_ModLines .=
  1015.           qq(\$Encode::ExtModule{'$enc'} = "$LocalMod{$enc}";\n);
  1016.     }
  1017.     warn $_ModLines;
  1018.     $_LocalVer = _mkversion();
  1019.     $_E2X      = find_e2x();
  1020.     $_Inc      = $INC{"Encode.pm"};
  1021.     $_Inc =~ s/\.pm$//o;
  1022.     _print_expand( File::Spec->catfile( $_E2X, "ConfigLocal_PM.e2x" ),
  1023.         File::Spec->catfile( $_Inc, "ConfigLocal.pm" ), 1 );
  1024.     exit;
  1025. }
  1026.  
  1027. sub _mkversion{
  1028.     # v-string is now depreciated; use time() instead;
  1029.     #my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime();
  1030.     #$yyyy += 1900, $mo +=1;
  1031.     #return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm);
  1032.     return time();
  1033. }
  1034.  
  1035. sub _print_expand{
  1036.     eval { require File::Basename; };
  1037.     $@ and die "File::Basename needed.  Are you on miniperl?;\nerror: $@\n";
  1038.     File::Basename->import();
  1039.     my ($src, $dst, $clobber) = @_;
  1040.     if (!$clobber and -e $dst){
  1041.     warn "$dst exists. skipping\n";
  1042.     return;
  1043.     }
  1044.     warn "Generating $dst...\n";
  1045.     open my $in, $src or die "$src : $!";
  1046.     if ((my $d = dirname($dst)) ne '.'){
  1047.     -d $d or mkdir $d, 0755 or die  "mkdir $d : $!";
  1048.     }       
  1049.     open my $out, ">$dst" or die "$!";
  1050.     my $asis = 0;
  1051.     while (<$in>){ 
  1052.     if (/^#### END_OF_HEADER/){
  1053.         $asis = 1; next;
  1054.     }      
  1055.     s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis;
  1056.     print $out $_;
  1057.     }
  1058. }
  1059. __END__
  1060.  
  1061. =head1 NAME
  1062.  
  1063. enc2xs -- Perl Encode Module Generator
  1064.  
  1065. =head1 SYNOPSIS
  1066.  
  1067.   enc2xs -[options]
  1068.   enc2xs -M ModName mapfiles...
  1069.   enc2xs -C
  1070.  
  1071. =head1 DESCRIPTION
  1072.  
  1073. F<enc2xs> builds a Perl extension for use by Encode from either
  1074. Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc).
  1075. Besides being used internally during the build process of the Encode
  1076. module, you can use F<enc2xs> to add your own encoding to perl.
  1077. No knowledge of XS is necessary.
  1078.  
  1079. =head1 Quick Guide
  1080.  
  1081. If you want to know as little about Perl as possible but need to
  1082. add a new encoding, just read this chapter and forget the rest.
  1083.  
  1084. =over 4
  1085.  
  1086. =item 0.
  1087.  
  1088. Have a .ucm file ready.  You can get it from somewhere or you can write
  1089. your own from scratch or you can grab one from the Encode distribution
  1090. and customize it.  For the UCM format, see the next Chapter.  In the
  1091. example below, I'll call my theoretical encoding myascii, defined
  1092. in I<my.ucm>.  C<$> is a shell prompt.
  1093.  
  1094.   $ ls -F
  1095.   my.ucm
  1096.  
  1097. =item 1.
  1098.  
  1099. Issue a command as follows;
  1100.  
  1101.   $ enc2xs -M My my.ucm
  1102.   generating Makefile.PL
  1103.   generating My.pm
  1104.   generating README
  1105.   generating Changes
  1106.  
  1107. Now take a look at your current directory.  It should look like this.
  1108.  
  1109.   $ ls -F
  1110.   Makefile.PL   My.pm         my.ucm        t/
  1111.  
  1112. The following files were created.
  1113.  
  1114.   Makefile.PL - MakeMaker script
  1115.   My.pm       - Encode submodule
  1116.   t/My.t      - test file
  1117.  
  1118. =over 4
  1119.  
  1120. =item 1.1.
  1121.  
  1122. If you want *.ucm installed together with the modules, do as follows;
  1123.  
  1124.   $ mkdir Encode
  1125.   $ mv *.ucm Encode
  1126.   $ enc2xs -M My Encode/*ucm
  1127.  
  1128. =back
  1129.  
  1130. =item 2.
  1131.  
  1132. Edit the files generated.  You don't have to if you have no time AND no
  1133. intention to give it to someone else.  But it is a good idea to edit
  1134. the pod and to add more tests.
  1135.  
  1136. =item 3.
  1137.  
  1138. Now issue a command all Perl Mongers love:
  1139.  
  1140.   $ perl Makefile.PL
  1141.   Writing Makefile for Encode::My
  1142.  
  1143. =item 4.
  1144.  
  1145. Now all you have to do is make.
  1146.  
  1147.   $ make
  1148.   cp My.pm blib/lib/Encode/My.pm
  1149.   /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \
  1150.     -o encode_t.c -f encode_t.fnm
  1151.   Reading myascii (myascii)
  1152.   Writing compiled form
  1153.   128 bytes in string tables
  1154.   384 bytes (75%) saved spotting duplicates
  1155.   1 bytes (0.775%) saved using substrings
  1156.   ....
  1157.   chmod 644 blib/arch/auto/Encode/My/My.bs
  1158.   $
  1159.  
  1160. The time it takes varies depending on how fast your machine is and
  1161. how large your encoding is.  Unless you are working on something big
  1162. like euc-tw, it won't take too long.
  1163.  
  1164. =item 5.
  1165.  
  1166. You can "make install" already but you should test first.
  1167.  
  1168.   $ make test
  1169.   PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \
  1170.     -e 'use Test::Harness  qw(&runtests $verbose); \
  1171.     $verbose=0; runtests @ARGV;' t/*.t
  1172.   t/My....ok
  1173.   All tests successful.
  1174.   Files=1, Tests=2,  0 wallclock secs
  1175.    ( 0.09 cusr + 0.01 csys = 0.09 CPU)
  1176.  
  1177. =item 6.
  1178.  
  1179. If you are content with the test result, just "make install"
  1180.  
  1181. =item 7.
  1182.  
  1183. If you want to add your encoding to Encode's demand-loading list
  1184. (so you don't have to "use Encode::YourEncoding"), run
  1185.  
  1186.   enc2xs -C
  1187.  
  1188. to update Encode::ConfigLocal, a module that controls local settings.
  1189. After that, "use Encode;" is enough to load your encodings on demand.
  1190.  
  1191. =back
  1192.  
  1193. =head1 The Unicode Character Map
  1194.  
  1195. Encode uses the Unicode Character Map (UCM) format for source character
  1196. mappings.  This format is used by IBM's ICU package and was adopted
  1197. by Nick Ing-Simmons for use with the Encode module.  Since UCM is
  1198. more flexible than Tcl's Encoding Map and far more user-friendly,
  1199. this is the recommended format for Encode now.
  1200.  
  1201. A UCM file looks like this.
  1202.  
  1203.   #
  1204.   # Comments
  1205.   #
  1206.   <code_set_name> "US-ascii" # Required
  1207.   <code_set_alias> "ascii"   # Optional
  1208.   <mb_cur_min> 1             # Required; usually 1
  1209.   <mb_cur_max> 1             # Max. # of bytes/char
  1210.   <subchar> \x3F             # Substitution char
  1211.   #
  1212.   CHARMAP
  1213.   <U0000> \x00 |0 # <control>
  1214.   <U0001> \x01 |0 # <control>
  1215.   <U0002> \x02 |0 # <control>
  1216.   ....
  1217.   <U007C> \x7C |0 # VERTICAL LINE
  1218.   <U007D> \x7D |0 # RIGHT CURLY BRACKET
  1219.   <U007E> \x7E |0 # TILDE
  1220.   <U007F> \x7F |0 # <control>
  1221.   END CHARMAP
  1222.  
  1223. =over 4
  1224.  
  1225. =item *
  1226.  
  1227. Anything that follows C<#> is treated as a comment.
  1228.  
  1229. =item *
  1230.  
  1231. The header section continues until a line containing the word
  1232. CHARMAP. This section has a form of I<E<lt>keywordE<gt> value>, one
  1233. pair per line.  Strings used as values must be quoted. Barewords are
  1234. treated as numbers.  I<\xXX> represents a byte.
  1235.  
  1236. Most of the keywords are self-explanatory. I<subchar> means
  1237. substitution character, not subcharacter.  When you decode a Unicode
  1238. sequence to this encoding but no matching character is found, the byte
  1239. sequence defined here will be used.  For most cases, the value here is
  1240. \x3F; in ASCII, this is a question mark.
  1241.  
  1242. =item *
  1243.  
  1244. CHARMAP starts the character map section.  Each line has a form as
  1245. follows:
  1246.  
  1247.   <UXXXX> \xXX.. |0 # comment
  1248.     ^     ^      ^
  1249.     |     |      +- Fallback flag
  1250.     |     +-------- Encoded byte sequence
  1251.     +-------------- Unicode Character ID in hex
  1252.  
  1253. The format is roughly the same as a header section except for the
  1254. fallback flag: | followed by 0..3.   The meaning of the possible
  1255. values is as follows:
  1256.  
  1257. =over 4
  1258.  
  1259. =item |0 
  1260.  
  1261. Round trip safe.  A character decoded to Unicode encodes back to the
  1262. same byte sequence.  Most characters have this flag.
  1263.  
  1264. =item |1
  1265.  
  1266. Fallback for unicode -> encoding.  When seen, enc2xs adds this
  1267. character for the encode map only.
  1268.  
  1269. =item |2 
  1270.  
  1271. Skip sub-char mapping should there be no code point.
  1272.  
  1273. =item |3 
  1274.  
  1275. Fallback for encoding -> unicode.  When seen, enc2xs adds this
  1276. character for the decode map only.
  1277.  
  1278. =back
  1279.  
  1280. =item *
  1281.  
  1282. And finally, END OF CHARMAP ends the section.
  1283.  
  1284. =back
  1285.  
  1286. When you are manually creating a UCM file, you should copy ascii.ucm
  1287. or an existing encoding which is close to yours, rather than write
  1288. your own from scratch.
  1289.  
  1290. When you do so, make sure you leave at least B<U0000> to B<U0020> as
  1291. is, unless your environment is EBCDIC.
  1292.  
  1293. B<CAVEAT>: not all features in UCM are implemented.  For example,
  1294. icu:state is not used.  Because of that, you need to write a perl
  1295. module if you want to support algorithmical encodings, notably
  1296. the ISO-2022 series.  Such modules include L<Encode::JP::2022_JP>,
  1297. L<Encode::KR::2022_KR>, and L<Encode::TW::HZ>.
  1298.  
  1299. =head2 Coping with duplicate mappings
  1300.  
  1301. When you create a map, you SHOULD make your mappings round-trip safe.
  1302. That is, C<encode('your-encoding', decode('your-encoding', $data)) eq
  1303. $data> stands for all characters that are marked as C<|0>.  Here is
  1304. how to make sure:
  1305.  
  1306. =over 4
  1307.  
  1308. =item * 
  1309.  
  1310. Sort your map in Unicode order.
  1311.  
  1312. =item *
  1313.  
  1314. When you have a duplicate entry, mark either one with '|1' or '|3'.
  1315.   
  1316. =item * 
  1317.  
  1318. And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry.
  1319.  
  1320. =back
  1321.  
  1322. Here is an example from big5-eten.
  1323.  
  1324.   <U2550> \xF9\xF9 |0
  1325.   <U2550> \xA2\xA4 |3
  1326.  
  1327. Internally Encoding -> Unicode and Unicode -> Encoding Map looks like
  1328. this;
  1329.  
  1330.   E to U               U to E
  1331.   --------------------------------------
  1332.   \xF9\xF9 => U2550    U2550 => \xF9\xF9
  1333.   \xA2\xA4 => U2550
  1334.  
  1335. So it is round-trip safe for \xF9\xF9.  But if the line above is upside
  1336. down, here is what happens.
  1337.  
  1338.   E to U               U to E
  1339.   --------------------------------------
  1340.   \xA2\xA4 => U2550    U2550 => \xF9\xF9
  1341.   (\xF9\xF9 => U2550 is now overwritten!)
  1342.  
  1343. The Encode package comes with F<ucmlint>, a crude but sufficient
  1344. utility to check the integrity of a UCM file.  Check under the
  1345. Encode/bin directory for this.
  1346.  
  1347. When in doubt, you can use F<ucmsort>, yet another utility under
  1348. Encode/bin directory.
  1349.  
  1350. =head1 Bookmarks
  1351.  
  1352. =over 4
  1353.  
  1354. =item *
  1355.  
  1356. ICU Home Page 
  1357. L<http://oss.software.ibm.com/icu/>
  1358.  
  1359. =item *
  1360.  
  1361. ICU Character Mapping Tables
  1362. L<http://oss.software.ibm.com/icu/charset/>
  1363.  
  1364. =item *
  1365.  
  1366. ICU:Conversion Data
  1367. L<http://oss.software.ibm.com/icu/userguide/conversion-data.html>
  1368.  
  1369. =back
  1370.  
  1371. =head1 SEE ALSO
  1372.  
  1373. L<Encode>,
  1374. L<perlmod>,
  1375. L<perlpod>
  1376.  
  1377. =cut
  1378.  
  1379. # -Q to disable the duplicate codepoint test
  1380. # -S make mapping errors fatal
  1381. # -q to remove comments written to output files
  1382. # -O to enable the (brute force) substring optimiser
  1383. # -o <output> to specify the output file name (else it's the first arg)
  1384. # -f <inlist> to give a file with a list of input files (else use the args)
  1385. # -n <name> to name the encoding (else use the basename of the input file.
  1386.  
  1387. With %seen holding array refs:
  1388.  
  1389.       865.66 real        28.80 user         8.79 sys
  1390.       7904  maximum resident set size
  1391.       1356  average shared memory size
  1392.      18566  average unshared data size
  1393.        229  average unshared stack size
  1394.      46080  page reclaims
  1395.      33373  page faults
  1396.  
  1397. With %seen holding simple scalars:
  1398.  
  1399.       342.16 real        27.11 user         3.54 sys
  1400.       8388  maximum resident set size
  1401.       1394  average shared memory size
  1402.      14969  average unshared data size
  1403.        236  average unshared stack size
  1404.      28159  page reclaims
  1405.       9839  page faults
  1406.  
  1407. Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
  1408. how %seen is storing things its seen. So it is pathalogically bad on a 16M
  1409. RAM machine, but it's going to help even on modern machines.
  1410. Swapping is bad, m'kay :-)
  1411.